perm filename PASS3.SAI[AL,HE]15 blob
sn#398427 filedate 1978-11-25 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00022 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00003 00002 IFCR ¬DECLARATION(EXTENDED_COMPILATION)
C00005 00003 ! Declarations, overall description
C00008 00004 ! EMITOFFSET, EMITSMLBLK
C00011 00005 ! EMITSUBS, EMITARGS, EMITCALL, PRINT_LIST
C00015 00006 ! EMITEXPR: ONEARG, TWOARGS, THREEARGS
C00019 00007 ! EMITEXPR: variable, constant
C00026 00008 ! EMITEXPR: expression
C00035 00009 ! EMITBOOL
C00037 00010 ! ENV_SIZE
C00040 00011 ! TSCAN: STMNT, PROG
C00043 00012 ! TSCAN: BLOCK
C00056 00013 ! TSCAN: BLOCK continued
C00064 00014 ! TSCAN: COBLOCK
C00067 00015 ! TSCAN: FORR, WHIL, UNTL, IFF, CASE, PAUSE, PROMPT, ABORT
C00076 00016 ! TSCAN: ASSIGNMENT, PRNT, CALL, RETURN, GASSIGN, ALSODO
C00079 00017 ! TSCAN: CMON, CMABLE
C00081 00018 ! TSCAN: MOVE$, CENTER, STOP, SETBASE, WRIST
C00092 00019 ! TSCAN: COMMENT, AFFIX, UNFIX
C00096 00020 ! TSCAN: EVDO
C00097 00021 ! UNRECOGNIZED
C00098 00022 ! Bugs
C00099 ENDMK
C⊗;
IFCR ¬DECLARATION(EXTENDED_COMPILATION)
THENC
ENTRY;
BEGIN "PASS3"
IFCR ¬DECLARATION(CREFFING) THENC DEFINE CREFFING = "FALSE"; ENDC
IFCR ¬ CREFFING THENC
COMMENT: Source file requirements;
REQUIRE "ABBREV.SAI[AL,HE]" SOURCE_FILE;
REQUIRE "RECAUX.HDR[AL,HE]" SOURCE_FILE;
REQUIRE "ARITH.HDR[AL,HE]" SOURCE_FILE ;
REQUIRE "ALREC.SAI[AL,HE]" SOURCE_FILE ;
ENDC
REDEFINE $$PRGID "[]" = ["PASS3"];
IFCR CREFFING THENC REQUIRE $$PRGID MESSAGE; ENDC
REQUIRE "EMITER.HDR[AL,HE]" SOURCE_FILE;
REQUIRE "INTDEF.SAI[AL,HE]" SOURCE_FILE;
ENDC
REQUIRE "EMITER.REL[AL,HE]" LOAD_MODULE;
! Standard emitter;
! Declarations, overall description;
RCELL USEDVARS; ! A list of variables as they appear. Used to
generate the needed list of graph node calculators;
! The word that heads a constant gives its type. (These are also used
by MVAR.) These are they:;
DEFINE SCLID = 1;
DEFINE VCTID = 2;
DEFINE TRNID = 3;
DEFINE EVTID = 4;
DEFINE CMNID = 5;
DEFINE ARYID = '1000;
DEFINE PROID = '4000;
DEFINE REFID = '2000; ! for procedure arguments;
! This file contains all the routines necessary for implementing the
third pass of AL, that is, the code generator.
The principal routine is TSCAN, which generates code for the root of
the bound parse tree and calls itself recursively for the rest. The
structures in this tree are defined in ALREC[AL,HE], page three.
TSCAN is a large IF-THEN-ELSE-IF-THEN chain which determines which of
the various possible structures is present. If it is some kind of
statement, then appropriate pseudo-code is emitted. The preparation
of this code may require that code for the evaluation of an
expression. Such code is prepared in the recursive procedure
EMITEXPR, which performs type-consistency checking (but not constant
folding, which could be done here). Code for boolean tests is
prepared by EMITBOOL.
All code emission is done through the routine EMIT, to be found in
EMITER.SAI, which takes arguments specifying what output file to use
(e.g., pseudo-code or constant area), the data to output, and whether
to treat it as an instruction, an octal constant, a label
declaration, or repeatedly to produce the rel file. ;
! EMITOFFSET, EMITSMLBLK;
INTERNAL PROCEDURE EMITOFFSET(INTEGER PC;RANY VARBL);
BEGIN "emitoffset"
! Outputs into the file PC the offset of VARBL, making a remark;
INTEGER DUMY;
IF RECTYPE(VARBL) = LOC(EXPRN) THEN VARBL ← CELL:CAR[EXPRN:ARGS[VARBL]];
MAKE_REMARK(PC,VARIABLE:NAME[VARBL]);
EMIT(PC,VARIABLE:OFFSET[VARBL],CONST);
END "emitoffset";
INTEGER PROCEDURE EMITSMLBLK
(INTEGER LENGTH; REFERENCE REAL FIRST_ELT; BOOLEAN REF (FALSE));
BEGIN "emitsmlblk"
! Emits a constant in the small block area. The length is
given, as is the first element, so that the whole thing can be
grabbed by location. Note that LENGTH must not be greater than
3. The label of the block is returned as the result if REF is
true, otherwise, no label is emitted.
;
OWN INTEGER ARRAY DATA [1:4]; ! maxlength + 1 long;
INTEGER ARRAY RELOC [1:4];
INTEGER J, ADDR, K;
IF LENGTH > 3
THEN BEGIN
COMERR("EMITSMLBLK cannot handle length = " & CVS(LENGTH));
LENGTH ← 3;
END;
IF REF
THEN BEGIN
DATA[1] ← GENLABEL;
RELOC[1] ← SYMDEC;
K ← 2;
END
ELSE K ← 1; ! Place for next entry in DATA, RELOC;
ADDR ← LOC(FIRST_ELT);
FOR J ← 0 STEP 1 UNTIL LENGTH-1 DO
BEGIN "stuff";
DATA[K] ← MEM[ADDR + J,INTEGER];
RELOC[K] ← FLOAT;
K ← K + 1;
END "stuff";
EMIT(SMLBLK,DATA[1],RELOC[1],K-1);
RETURN(IF REF THEN DATA[1] ELSE -1);
END "emitsmlblk";
! EMITSUBS, EMITARGS, EMITCALL, PRINT_LIST;
FORWARD INTERNAL RECURSIVE INTEGER PROCEDURE EMITEXPR
(REXPR XPRESS;BOOLEAN GET(TRUE));
RECURSIVE PROCEDURE EMITSUBS(RCELL C);
BEGIN ! place subscripts on stack;
IF C = RNULL THEN RETURN;
EMITSUBS(CELL:CDR[C]);
EMITEXPR(CELL:CAR[C])
END;
RECURSIVE PROCEDURE EMITARGS(RCELL A);
BEGIN ! puts expressions on stack;
IF A = RNULL THEN RETURN;
EMITARGS(CELL:CDR[A]);
IF RECTYPE(CELL:CAR[A]) = LOC(EXPRN) THEN
IF EXPRN:OP[CELL:CAR[A]] = AREF_OP THEN ! put subscripts on stack;
EMITSUBS(CELL:CDR[EXPRN:ARGS[CELL:CAR[A]]])
ELSE EMITEXPR(CELL:CAR[A]) ! put expression on stack;
END;
RECURSIVE INTEGER PROCEDURE EMITCALL(REXPR E);
BEGIN ! generates code for a procedure call;
RCELL C;
C ← EXPRN:ARGS[E];
EMITARGS(CELL:CDR[C]); ! put any expressions on stack;
EMIT(PSDCODE,PROC_PSOP,PSINST); ! generate the procedure call;
EMITOFFSET(PSDCODE,LLOP(C));
WHILE C ≠ RNULL DO ! now generate the argument list;
BEGIN
IF RECTYPE(CELL:CAR[C]) = LOC(EXPRN)
∧ EXPRN:OP[CELL:CAR[C]] ≠ AREF_OP THEN
EMIT(PSDCODE,'177777,CONST) ! expr's value is on stack;
ELSE EMITEXPR(CELL:CAR[C],FALSE); ! give offset/address;
C ← CELL:CDR[C]
END;
RETURN(PROCDEF:DATATYPE[CELL:CAR[EXPRN:ARGS[E]]])
END;
RECURSIVE PROCEDURE PRINT_LIST(RCELL C);
BEGIN
INTEGER LAB;
IF C ≠ RNULL THEN MAKE_REMARK(PSDCODE,"Print");
WHILE C ≠ RNULL DO
BEGIN "print list"
IF RECTYPE(CELL:CAR[C]) = LOC(STCONST)
THEN BEGIN "prntstr"
INTEGER ADR;
ADR ← LOC(STCONST:VAL[CELL:CAR[C]]);
LAB ← GENLABEL;
EMIT(SMLBLK,LAB,SYMDEC);
EMIT(SMLBLK,ADR,STRCONST);
EMIT(PSDCODE,PRINT_PSOP,PSINST);
EMIT(PSDCODE,LAB,SYMREF);
END "prntstr"
ELSE BEGIN "prntexpr"
! Get the value on the stack;
EMITEXPR(CELL:CAR[C]);
EMIT(PSDCODE,VALPRN_PSOP,PSINST);
END "prntexpr";
C ← CELL:CDR[C];
END "print list"
END;
! EMITEXPR: ONEARG, TWOARGS, THREEARGS;
INTERNAL RECURSIVE INTEGER PROCEDURE EMITEXPR (REXPR XPRESS;BOOLEAN GET(TRUE));
! Emits code for XPRESS, the value of which is to be left at top
of stack, returns the type of the expression. FRAME_DTYPE is
never returned. It is coerced to TRANS_DTYPE;
BEGIN "emitexpr"
INTEGER RTYPE, DTYPE;
RECURSIVE PROCEDURE ONEARG(INTEGER ARG1TYPE,OPERATION,RESTYPE);
BEGIN ! Pick up one argument, evaluate;
REXPR XXX;
XXX ← XPRESS; ! because of a SAIL Bug;
MAKE_REMARK(PSDCODE,"first argument");
IF EMITEXPR(CELL:CAR[EXPRN:ARGS[XXX]]) ≠ ARG1TYPE
THEN COMERR("Wrong type of argument",XXX);
EMIT(PSDCODE,OPERATION,PSINST);
DTYPE ← RESTYPE;
END;
RECURSIVE PROCEDURE TWOARGS
(INTEGER ARG1TYPE,ARG2TYPE,OPERATION,RESTYPE);
BEGIN ! Pick up two arguments, evaluate them;
REXPR XXX;
XXX ← XPRESS; ! because of a SAIL Bug;
MAKE_REMARK(PSDCODE,"first argument");
IF EMITEXPR(CELL:CAR[EXPRN:ARGS[XXX]]) ≠ ARG1TYPE
THEN COMERR("Wrong type for first argument",XXX);
MAKE_REMARK(PSDCODE,"second argument");
IF EMITEXPR(CADR(EXPRN:ARGS[XXX])) ≠ ARG2TYPE
THEN COMERR("Wrong type for second argument",XXX);
EMIT(PSDCODE,OPERATION,PSINST);
DTYPE ← RESTYPE;
END;
RECURSIVE PROCEDURE THREEARGS
(INTEGER ARG1TYPE,ARG2TYPE,ARG3TYPE,OPERATION,RESTYPE);
BEGIN ! Pick up three arguments, evaluate;
REXPR XXX;
XXX ← XPRESS; ! because of a SAIL Bug;
MAKE_REMARK(PSDCODE,"first argument");
IF EMITEXPR(CELL:CAR[EXPRN:ARGS[XXX]]) ≠ ARG1TYPE
THEN COMERR("Wrong type for first argument",XXX);
MAKE_REMARK(PSDCODE,"second argument");
IF EMITEXPR(CADR(EXPRN:ARGS[XXX])) ≠ ARG2TYPE
THEN COMERR("Wrong type for second argument",XXX);
MAKE_REMARK(PSDCODE,"third argument");
IF EMITEXPR(CADDR(EXPRN:ARGS[XXX])) ≠ ARG3TYPE
THEN COMERR("Wrong type for third argument",XXX);
EMIT(PSDCODE,OPERATION,PSINST);
DTYPE ← RESTYPE;
END;
! EMITEXPR: variable, constant;
PRELOAD_WITH PUSH_PSOP, DUMMY;
OWN INTEGER ARRAY DATA[0:1];
PRELOAD_WITH PSINST, SYMREF;
OWN INTEGER ARRAY RELOC [0:1];
! To emit constants but once a list of already emitted constants is kept;
RECORD_CLASS CONLST(RPTR(SVAL,V3ECT,ROTN,TRANS) VAL; INTEGER LAB;
RPTR(CONLST) NEXT);
OWN RPTR(CONLST) SVAL_HDR,V3ECT_HDR,ROTN_HDR,TRANS_HDR;
RPTR(CONLST) PTR;
INTEGER LAB;
RTYPE ← RECTYPE(XPRESS);
! A variable?;
IF RTYPE = LOC(VARIABLE) ∨ RTYPE = LOC(ARRAYDEF)
THEN BEGIN "variable"
IF GET THEN EMIT(PSDCODE,GTVAL_PSOP,PSINST);
EMITOFFSET(PSDCODE,XPRESS);
DTYPE ← VARIABLE:DATATYPE[XPRESS];
USEDVARS ← CONS(XPRESS,USEDVARS);
END "variable"
! A constant?;
ELSE IF RTYPE = LOC(SVAL)
THEN BEGIN "scalar"
PTR ← SVAL_HDR; ! Check if it's already been emitted;
WHILE PTR ≠ RNULL DO
IF SVAL:VAL[XPRESS] = SVAL:VAL[CONLST:VAL[PTR]] THEN DONE
ELSE PTR ← CONLST:NEXT[PTR];
IF PTR = RNULL THEN
BEGIN ! Emit the scalar & add it to the conlst;
EMIT(SMLBLK,SCLID,CONST); ! Header for typing;
LAB ← EMITSMLBLK(1,SVAL:VAL[XPRESS],TRUE);
PTR ← NEW_RECORD(CONLST);
CONLST:VAL[PTR] ← XPRESS;
CONLST:LAB[PTR] ← LAB;
CONLST:NEXT[PTR] ← SVAL_HDR;
SVAL_HDR ← PTR;
END
ELSE LAB ← CONLST:LAB[PTR];
DATA[1] ← LAB;
IF GET THEN EMIT(PSDCODE,DATA[0],RELOC[0],2)
ELSE EMIT(PSDCODE,LAB,SYMREF);
DTYPE ← SVAL_DTYPE;
END "scalar"
ELSE IF RTYPE = LOC(V3ECT)
THEN BEGIN "vector"
PTR ← V3ECT_HDR; ! Check if it's already been emitted;
WHILE PTR ≠ RNULL DO
IF V3CMP(XPRESS,CONLST:VAL[PTR]) THEN PTR ← CONLST:NEXT[PTR]
ELSE DONE;
IF PTR = RNULL THEN
BEGIN ! Emit the vector & add it to the conlst;
EMIT(SMLBLK,VCTID,CONST); ! Header for typing;
LAB ← EMITSMLBLK(3,V3ECT:X[XPRESS],TRUE);
EMITSMLBLK(1,1.0); ! This puts the scale factor in;
PTR ← NEW_RECORD(CONLST);
CONLST:VAL[PTR] ← XPRESS;
CONLST:LAB[PTR] ← LAB;
CONLST:NEXT[PTR] ← V3ECT_HDR;
V3ECT_HDR ← PTR;
END
ELSE LAB ← CONLST:LAB[PTR];
DATA[1] ← LAB;
IF GET THEN EMIT(PSDCODE,DATA[0],RELOC[0],2)
ELSE EMIT(PSDCODE,LAB,SYMREF);
DTYPE ← V3ECT_DTYPE;
END "vector"
ELSE IF RTYPE = LOC(ROTN)
THEN BEGIN "rot" ! Will output the equivalent trans;
PTR ← ROTN_HDR; ! Check if it's already been emitted;
WHILE PTR ≠ RNULL DO
IF ROTCMP(XPRESS,CONLST:VAL[PTR]) THEN PTR ← CONLST:NEXT[PTR]
ELSE DONE;
IF PTR = RNULL THEN
BEGIN ! Emit the rotn & add it to the conlst;
EMIT(SMLBLK,TRNID,CONST); ! Header for typing;
LAB ← EMITSMLBLK(3,ROTN:RMX[XPRESS][1,1],TRUE);
EMITSMLBLK(3,ROTN:RMX[XPRESS][2,1]);
EMITSMLBLK(3,ROTN:RMX[XPRESS][3,1]);
EMITSMLBLK(3,V3ECT:X[NILVECT]); ! The fourth column;
PTR ← NEW_RECORD(CONLST);
CONLST:VAL[PTR] ← XPRESS;
CONLST:LAB[PTR] ← LAB;
CONLST:NEXT[PTR] ← ROTN_HDR;
ROTN_HDR ← PTR;
END
ELSE LAB ← CONLST:LAB[PTR];
DATA[1] ← LAB;
IF GET THEN EMIT(PSDCODE,DATA[0],RELOC[0],2)
ELSE EMIT(PSDCODE,LAB,SYMREF);
DTYPE ← ROTN_DTYPE;
END "rot"
ELSE IF RTYPE = LOC(TRANS)
THEN BEGIN "trans"
PTR ← TRANS_HDR; ! Check if it's already been emitted;
WHILE PTR ≠ RNULL DO
IF TRANSCMP(XPRESS,CONLST:VAL[PTR]) THEN PTR ← CONLST:NEXT[PTR]
ELSE DONE;
IF PTR = RNULL THEN
BEGIN ! Emit the trans & add it to the conlst;
EMIT(SMLBLK,TRNID,CONST); ! Header for typing;
LAB ← EMITSMLBLK(3,ROTN:RMX[TRANS:R[XPRESS]][1,1],TRUE);
EMITSMLBLK(3,ROTN:RMX[TRANS:R[XPRESS]][2,1]);
EMITSMLBLK(3,ROTN:RMX[TRANS:R[XPRESS]][3,1]);
EMITSMLBLK(3,V3ECT:X[TRANS:P[XPRESS]]); ! The fourth column;
PTR ← NEW_RECORD(CONLST);
CONLST:VAL[PTR] ← XPRESS;
CONLST:LAB[PTR] ← LAB;
CONLST:NEXT[PTR] ← TRANS_HDR;
TRANS_HDR ← PTR;
END
ELSE LAB ← CONLST:LAB[PTR];
DATA[1] ← LAB;
IF GET THEN EMIT(PSDCODE,DATA[0],RELOC[0],2)
ELSE EMIT(PSDCODE,LAB,SYMREF);
DTYPE ← TRANS_DTYPE;
END "trans"
ELSE IF RTYPE = LOC(FRAME)
THEN BEGIN "frame" ! Recursive call to pick up the trans inside;
EMITEXPR(FRAME:VAL[XPRESS],GET);
DTYPE ← FRAME_DTYPE;
END "frame"
! EMITEXPR: expression;
! An expression?;
ELSE IF RTYPE = LOC(EXPRN)
THEN BEGIN "recurse"
INTEGER OPR;
OPR ← EXPRN:OP[XPRESS];
IF OPR < 0 ∨ OPR ≥ LAST_OP
THEN BEGIN
COMERR("Illegal expression",XPRESS);
DTYPE ← 0;
END
ELSE CASE OPR OF
BEGIN "case"
[NO_OP] DTYPE ← EMITEXPR(CELL:CAR[EXPRN:ARGS[XPRESS]]);
[SCALRD_OP] BEGIN
EMIT(PSDCODE,SCALRD_PSOP,PSINST);
DTYPE ← SVAL_DTYPE
END;
[QUERY_OP] BEGIN
PRINT_LIST(EXPRN:ARGS[XPRESS]); ! Take care of any print items;
EMIT(PSDCODE,QUERY_PSOP,PSINST);
DTYPE ← SVAL_DTYPE
END;
[SABS_OP] ONEARG(SVAL_DTYPE,SABS_PSOP,SVAL_DTYPE);
[SADD_OP] TWOARGS(SVAL_DTYPE,SVAL_DTYPE,SADD_PSOP,SVAL_DTYPE);
[SNEG_OP] ONEARG(SVAL_DTYPE,SNEG_PSOP,SVAL_DTYPE);
[SSUB_OP] TWOARGS(SVAL_DTYPE,SVAL_DTYPE,SSUB_PSOP,SVAL_DTYPE);
[SMUL_OP] TWOARGS(SVAL_DTYPE,SVAL_DTYPE,SMUL_PSOP,SVAL_DTYPE);
[SDIV_OP] TWOARGS(SVAL_DTYPE,SVAL_DTYPE,SDIV_PSOP,SVAL_DTYPE);
[SEXP_OP] TWOARGS(SVAL_DTYPE,SVAL_DTYPE,SEXP_PSOP,SVAL_DTYPE);
[MAX_OP] TWOARGS(SVAL_DTYPE,SVAL_DTYPE,MAX_PSOP,SVAL_DTYPE);
[MIN_OP] TWOARGS(SVAL_DTYPE,SVAL_DTYPE,MIN_PSOP,SVAL_DTYPE);
[INT_OP] ONEARG(SVAL_DTYPE,INT_PSOP,SVAL_DTYPE);
[DIV_OP] TWOARGS(SVAL_DTYPE,SVAL_DTYPE,IDIV_PSOP,SVAL_DTYPE);
[MOD_OP] TWOARGS(SVAL_DTYPE,SVAL_DTYPE,MOD_PSOP,SVAL_DTYPE);
[SLT_OP] TWOARGS(SVAL_DTYPE,SVAL_DTYPE,SLT_PSOP,SVAL_DTYPE);
[SEQ_OP] TWOARGS(SVAL_DTYPE,SVAL_DTYPE,SEQ_PSOP,SVAL_DTYPE);
[SLE_OP] TWOARGS(SVAL_DTYPE,SVAL_DTYPE,SLE_PSOP,SVAL_DTYPE);
[SGE_OP] TWOARGS(SVAL_DTYPE,SVAL_DTYPE,SGE_PSOP,SVAL_DTYPE);
[SNE_OP] TWOARGS(SVAL_DTYPE,SVAL_DTYPE,SNE_PSOP,SVAL_DTYPE);
[SGT_OP] TWOARGS(SVAL_DTYPE,SVAL_DTYPE,SGT_PSOP,SVAL_DTYPE);
[AND_OP] TWOARGS(SVAL_DTYPE,SVAL_DTYPE,AND_PSOP,SVAL_DTYPE);
[OR_OP] TWOARGS(SVAL_DTYPE,SVAL_DTYPE,LOR_PSOP,SVAL_DTYPE);
[NOT_OP] ONEARG(SVAL_DTYPE,NOT_PSOP,SVAL_DTYPE);
[XOR_OP] TWOARGS(SVAL_DTYPE,SVAL_DTYPE,LXOR_PSOP,SVAL_DTYPE);
[EQV_OP] TWOARGS(SVAL_DTYPE,SVAL_DTYPE,EQV_PSOP,SVAL_DTYPE);
[VMAGN_OP] ONEARG(V3ECT_DTYPE,VMAGN_PSOP,SVAL_DTYPE);
[VDOT_OP] TWOARGS(V3ECT_DTYPE,V3ECT_DTYPE,VDOT_PSOP,SVAL_DTYPE);
[RMAGN_OP] ONEARG(ROTN_DTYPE,TMAGN_PSOP,SVAL_DTYPE);
[AXIS_OP] ONEARG(ROTN_DTYPE,TAXIS_PSOP,V3ECT_DTYPE);
[VMAKE_OP] THREEARGS(SVAL_DTYPE,SVAL_DTYPE,SVAL_DTYPE,VMAKE_PSOP,V3ECT_DTYPE);
[SVMUL_OP] TWOARGS(SVAL_DTYPE,V3ECT_DTYPE,SVMUL_PSOP,V3ECT_DTYPE);
[VSDIV_OP] TWOARGS(V3ECT_DTYPE,SVAL_DTYPE,VSDIV_PSOP,V3ECT_DTYPE);
[VADD_OP] TWOARGS(V3ECT_DTYPE,V3ECT_DTYPE,VADD_PSOP,V3ECT_DTYPE);
[VSUB_OP] TWOARGS(V3ECT_DTYPE,V3ECT_DTYPE,VSUB_PSOP,V3ECT_DTYPE);
[VCROSS_OP] TWOARGS(V3ECT_DTYPE,V3ECT_DTYPE,VCROSS_PSOP,V3ECT_DTYPE);
[RVMUL_OP] TWOARGS(ROTN_DTYPE,V3ECT_DTYPE,TVMUL_PSOP,V3ECT_DTYPE);
[TVMUL_OP] TWOARGS(TRANS_DTYPE,V3ECT_DTYPE,TVMUL_PSOP,V3ECT_DTYPE);
[UVECT_OP] ONEARG(V3ECT_DTYPE,UNITV_PSOP,V3ECT_DTYPE);
[POS_OP] ONEARG(TRANS_DTYPE,TPOS_PSOP,V3ECT_DTYPE);
[ORIENT_OP] ONEARG(TRANS_DTYPE,TORIEN_PSOP,ROTN_DTYPE);
[AXW_ROTN_OP] TWOARGS(V3ECT_DTYPE,SVAL_DTYPE,VSAXWR_PSOP,ROTN_DTYPE);
[TMAKE_OP] TWOARGS(ROTN_DTYPE,V3ECT_DTYPE,TMAKE_PSOP,TRANS_DTYPE);
[CONSTR_OP] THREEARGS(V3ECT_DTYPE,V3ECT_DTYPE,V3ECT_DTYPE,CONSTR_PSOP,TRANS_DTYPE);
[TVADD_OP] TWOARGS(TRANS_DTYPE,V3ECT_DTYPE,TVADD_PSOP,TRANS_DTYPE);
[TVSUB_OP] TWOARGS(TRANS_DTYPE,V3ECT_DTYPE,TVSUB_PSOP,TRANS_DTYPE);
[RRMUL_OP] TWOARGS(ROTN_DTYPE,ROTN_DTYPE,TTMUL_PSOP,ROTN_DTYPE);
[TTMUL_OP] TWOARGS(TRANS_DTYPE,TRANS_DTYPE,TTMUL_PSOP,TRANS_DTYPE);
[TINVRT_OP] ONEARG(TRANS_DTYPE,TINVRT_PSOP,TRANS_DTYPE);
[FTOF_OP] BEGIN ! A→B ≡ INV(A)*B;
ONEARG(TRANS_DTYPE,TINVRT_PSOP,TRANS_DTYPE);
IF EMITEXPR(CADR(EXPRN:ARGS[XPRESS])) ≠ TRANS_DTYPE
THEN COMERR("Wrong type for second argument",XPRESS);
EMIT(PSDCODE,TTMUL_PSOP,PSINST);
END;
[DEPR_OP] DTYPE ← EMITEXPR(CADR(EXPRN:ARGS[XPRESS]));
[FMAKE_OP] TWOARGS(ROTN_DTYPE,V3ECT_DTYPE,TMAKE_PSOP,TRANS_DTYPE);
[SSBRTN_OP] BEGIN
INTEGER OPTYPE;
IF (OPTYPE←SVAL:VAL[CELL:CAR[EXPRN:ARGS[XPRESS]]]) = ATAN2_OP
THEN BEGIN
MAKE_REMARK(PSDCODE,"second argument");
IF EMITEXPR(CADDR(EXPRN:ARGS[XPRESS])) ≠ SVAL_DTYPE
THEN COMERR("Wrong type of argument",XPRESS);
END;
MAKE_REMARK(PSDCODE,"first argument");
IF EMITEXPR(CADR(EXPRN:ARGS[XPRESS])) ≠ SVAL_DTYPE
THEN COMERR("Wrong type of argument",XPRESS);
EMIT(PSDCODE,SSBRTN_PSOP,PSINST);
MAKE_REMARK(PSDCODE,
CASE OPTYPE-1 OF ("sqrt","sin","cos","asin","acos","atan2",
"log","exp"));
EMIT(PSDCODE,OPTYPE,CONST);
DTYPE ← SVAL_DTYPE;
END;
[AREF_OP] BEGIN
IF GET THEN
BEGIN
MAKE_REMARK(PSDCODE,"Array reference");
EMITSUBS(CELL:CDR[EXPRN:ARGS[XPRESS]]);
EMIT(PSDCODE,GTVAL_PSOP,PSINST)
END;
EMITOFFSET(PSDCODE,CELL:CAR[EXPRN:ARGS[XPRESS]]);
DTYPE ← ARRAYDEF:DATATYPE[CELL:CAR[EXPRN:ARGS[XPRESS]]]
END;
[CALL_OP] DTYPE ← EMITCALL(XPRESS);
[INVALID_OP] COMERR("Invalid operator",XPRESS)
END "case";
IF DTYPE ≠ EXPRN:DATATYPE[XPRESS] ∧
( DTYPE ≠ TRANS_DTYPE ∨ EXPRN:DATATYPE[XPRESS] ≠ FRAME_DTYPE )
THEN COMERR("Type consistency error in EMITEXPR: " & CVS(DTYPE) &" ≠ " &
CVS(EXPRN:DATATYPE[XPRESS]) & ".",XPRESS);
END "recurse"
ELSE BEGIN
COMERR("Garbage expression",XPRESS);
DTYPE ← 0;
END;
IF DTYPE = FRAME_DTYPE THEN DTYPE ← TRANS_DTYPE;
RETURN(DTYPE);
END "emitexpr";
! EMITBOOL;
PROCEDURE EMITBOOL(REXPR CONDITION; INTEGER DESTTRUE (0), DESTFALSE (0));
BEGIN "emitbool"
! Generates code to evaluate the condition. If it succeeds,
there should be a jump to DESTTRUE, if false, to DESTFALSE. If
either is 0, instead of jumping there, fall through;
! modified by arg 9-14-76;
IF DESTFALSE
THEN BEGIN "fjump"
! Put the tested result on the stack;
IF EMITEXPR(CONDITION) ≠ SVAL_DTYPE
THEN COMERR("Non-scalar boolean",CONDITION);
EMIT(PSDCODE,JUMPC_PSOP,PSINST,1); ! JUMPC;
EMIT(PSDCODE,DESTFALSE,SYMREF,1); ! (ref) DESTFALSE;
IF DESTTRUE
THEN BEGIN "tfjump"
EMIT(PSDCODE,JUMP_PSOP,PSINST,1); ! JUMP;
EMIT(PSDCODE,DESTTRUE,SYMREF,1); ! (ref) DESTTRUE;
END "tfjump"
END "fjump"
ELSE IF DESTTRUE
THEN BEGIN "tjump"
! Put the tested result on the stack;
IF EMITEXPR(CONDITION) ≠ SVAL_DTYPE
THEN COMERR("Non-scalar boolean",CONDITION);
EMIT(PSDCODE,NOT_PSOP,PSINST,1); ! Take the complement of the boolean;
EMIT(PSDCODE,JUMPC_PSOP,PSINST,1); ! JUMPC;
EMIT(PSDCODE,DESTTRUE,SYMREF,1); ! (ref) DESTTRUE;
END "tjump";
END "emitbool";
! ENV_SIZE;
RECURSIVE INTEGER PROCEDURE ENV_SIZE(RANY BLK);
BEGIN
INTEGER SIZE,S;
RANY P;
IF (S ← RECTYPE(BLK)) = LOC(STMNT) THEN
BEGIN
BLK ← STMNT:SEMANTICS[BLK];
IF BLK = RNULL THEN RETURN(0) ELSE S ← RECTYPE(BLK);
END;
IF S = LOC(BLOCK) THEN
BEGIN "blk"
SIZE ← 0;
P ← BLOCK:VARS[BLK];
WHILE P ≠ RNULL DO BEGIN SIZE ← SIZE + 1; ! Count algebraic vars;
P ← CELL:CDR[P] END;
P ← BLOCK:ARAYS[BLK];
WHILE P ≠ RNULL DO BEGIN SIZE ← SIZE + 1; ! Count arrays;
P ← CELL:CDR[P] END;
P ← BLOCK:EVTS[BLK];
WHILE P ≠ RNULL DO BEGIN SIZE ← SIZE + 1; ! Count events;
P ← CELL:CDR[P] END;
P ← BLOCK:CMONS[BLK];
WHILE P ≠ RNULL DO BEGIN SIZE ← SIZE + 1; ! Count cmons;
P ← CELL:CDR[P] END;
P ← BLOCK:PROCS[BLK];
WHILE P ≠ RNULL DO BEGIN SIZE ← SIZE + 1; ! Count procedures;
P ← CELL:CDR[P] END;
S ← 0;
P ← BLOCK:CODE[BLK];
WHILE P ≠ RNULL DO S ← S MAX ENV_SIZE(LLOP(P)); ! Check for nested blocks;
RETURN(SIZE+S);
END "blk"
ELSE IF S = LOC(FORR) THEN RETURN(ENV_SIZE(FORR:BODY[BLK]))
ELSE IF S = LOC(WHIL) THEN RETURN(ENV_SIZE(WHIL:BODY[BLK]))
ELSE IF S = LOC(UNTL) THEN RETURN(ENV_SIZE(UNTL:BODY[BLK]))
ELSE IF S = LOC(IFF) THEN
RETURN(ENV_SIZE(IFF:THN[BLK]) MAX ENV_SIZE(IFF:ELS[BLK]))
ELSE IF S = LOC(KASE) THEN
BEGIN
S ← 0;
P ← KASE:STMNTS[BLK];
WHILE P≠RNULL DO S ← S MAX ENV_SIZE(LLOP(P)); ! check for nested blocks;
RETURN(S)
END
ELSE RETURN(0);
END;
! TSCAN: STMNT, PROG;
INTEGER OFS; ! The current offset for variables;
INITIALIZE (OFS ← '400); ! Level 1, offset 0;
INTERNAL RECURSIVE PROCEDURE TSCAN (RANY PARSETREE);
BEGIN "tscan"
! TSCAN takes a parse tree and interprets its nodes, calling
appropriate routines to prepare code for each node;
INTEGER STYP, ! Statement type;
LAB1, LAB2, LAB3, LAB4;
! Save labels across recursive calls. Cannot
save in DATA since that is an OWN array;
RPTR(STMNT) STATEMENT;
LABEL MIDLABEL, ENDLABEL; ! This is to prevent parse stack overflow;
STYP ← RECTYPE(PARSETREE);
IF STYP = LOC(STMNT) THEN
BEGIN "stmnt"
! Eventually will want to output labelling information here;
STATEMENT ← PARSETREE;
PARSETREE ← STMNT:SEMANTICS[PARSETREE];
IF PARSETREE = RNULL THEN RETURN;
STYP ← RECTYPE(PARSETREE);
END "stmnt";
IF STYP = LOC(VARIABLE) ∨ STYP = LOC(PVL) ∨ STYP = LOC(PAS)
∨ STYP = LOC(S_FAC) ∨ STYP = LOC(NOTE1) ∨ STYP = LOC(DEPROACH) THEN
! Just ignore it. Variable declarations are treated with
block entry and exit. Others handled only during world modelling;
ELSE IF STYP = LOC(NOTE) THEN
PRINT(STCONST:VAL[NOTE:HESAYS[PARSETREE]],CRLF)
ELSE IF STYP = LOC(NOTE2) THEN
PRINT(STCONST:VAL[NOTE2:HESAYS[PARSETREE]],CRLF)
ELSE IF STYP = LOC(PROG) THEN
BEGIN "prog"
MAKE_REMARK(PSDCODE,"Start of program");
EMIT(PSDCODE,PROG_PSOP,PSINST); ! Make mechanism variables;
LAB4 ← ENV_SIZE(PROG:CODE[PARSETREE]);
EMIT(PSDCODE,LAB4,CONST); ! Environment size needed by program;
TSCAN(PROG:CODE[PARSETREE]);
EMIT(PSDCODE,ENDP_PSOP,PSINST); ! Clean up mechanism variables;
MAKE_REMARK(PSDCODE,"End of program");
CLOSEOUT; ! Closes the output file;
END "prog"
! TSCAN: BLOCK;
ELSE IF STYP = LOC(BLOCK) THEN
BEGIN "block"
RCELL C; ! Holds variable list and current tail of block;
INTEGER DUMY, COFS, SAVOFS; ! Holds OFS for the duration;
INTEGER CNT, CTYPE, T, BITS;
RVAR VARBL; ! Temporary: variable under consideration;
RANY F,P;
RPTR(CMON) MONITOR; ! Temporary: cmon under consideration;
RCLASS COLAB (INTEGER LBEL; RPTR(COLAB) NEXT);
RPTR (COLAB) LABELS, HERE;
INTEGER PROCEDURE TYPE_GET(INTEGER DTYPE);
CASE DTYPE OF
BEGIN
[SVAL_DTYPE] RETURN(SCLID);
[V3ECT_DTYPE] RETURN(VCTID);
[ROTN_DTYPE] [TRANS_DTYPE] [FRAME_DTYPE] RETURN(TRNID);
[EVENT_DTYPE] RETURN(EVTID);
ELSE RETURN(0)
END;
INTEGER PROCEDURE VAR_CNT(INTEGER DTYPE);
BEGIN ! Count & assign offsets to all variables of specified type;
INTEGER CNT;
C ← BLOCK:VARS[PARSETREE];
CNT ← 0;
WHILE C ≠ RNULL DO
BEGIN
VARBL ← LLOP(C);
IF VARIABLE:DATATYPE[VARBL] = DTYPE THEN
BEGIN
CNT ← CNT + 1;
VARIABLE:OFFSET[VARBL] ← OFS;
EMITOFFSET(SYMFIL,VARBL);
OFS ← OFS + 1;
END;
END;
RETURN(CNT)
END;
MAKE_REMARK(PSDCODE,"BLOCK");
SAVOFS ← OFS; ! We will assign new offsets in this block.;
IF BLOCK:VARS[PARSETREE] ≠ RNULL ∨ BLOCK:ARAYS[PARSETREE] ≠ RNULL ∨
BLOCK:EVTS[PARSETREE] ≠ RNULL ∨ BLOCK:PROCS[PARSETREE] ≠ RNULL ∨
BLOCK:CMONS[PARSETREE] ≠ RNULL THEN BEGIN "make some variables"
! Emit code to compute any array bounds expressions;
C ← BLOCK:ARAYS[PARSETREE];
WHILE C ≠ RNULL DO
BEGIN
F ← LLOP(C); ! Get array header;
FOR CNT ← 1 TIL ARRAYDEF:NUMDIMS[F] DO
FOR T ← 0 TIL 1 DO
IF RECTYPE(ARRAYDEF:BOUNDS[F][CNT,T]) = LOC(EXPRN) THEN
BEGIN
MAKE_REMARK(PSDCODE,"Array bounds expression");
EMITEXPR(ARRAYDEF:BOUNDS[F][CNT,T]);
EMIT(PSDCODE,CHNGE_PSOP,PSINST);
EMITOFFSET(PSDCODE,ARRAYDEF:BOUNDS[F][CNT,T+2])
END
END;
! Declare variables;
EMIT(PSDCODE,MVAR_PSOP,PSINST); ! variable declaration;
IF (T ← VAR_CNT(SVAL_DTYPE))≠0 THEN
BEGIN
MAKE_REMARK(PSDCODE,"Scalars");
EMIT(PSDCODE,SCLID,CONST);
EMIT(PSDCODE,T,CONST);
END;
IF (T ← VAR_CNT(V3ECT_DTYPE))≠0 THEN
BEGIN
MAKE_REMARK(PSDCODE,"Vectors");
EMIT(PSDCODE,VCTID,CONST);
EMIT(PSDCODE,T,CONST);
END;
IF (T←VAR_CNT(ROTN_DTYPE)+VAR_CNT(TRANS_DTYPE)+VAR_CNT(FRAME_DTYPE))≠0 THEN
BEGIN
MAKE_REMARK(PSDCODE,"Transes");
EMIT(PSDCODE,TRNID,CONST);
EMIT(PSDCODE,T,CONST);
END;
! Declare the arrays;
C ← BLOCK:ARAYS[PARSETREE];
IF C ≠ RNULL THEN MAKE_REMARK(PSDCODE,"Arrays");
WHILE C ≠ RNULL DO
BEGIN
F ← LLOP(C); ! Get the array header;
MAKE_REMARK(PSDCODE,ARRAYDEF:NAME[F]);
ARRAYDEF:OFFSET[F] ← OFS;
EMITOFFSET(SYMFIL,F);
OFS ← OFS + 1;
T ← TYPE_GET(ARRAYDEF:DATATYPE[F]) + ARYID;
EMIT(PSDCODE,T,CONST); ! Emit the datatype;
EMIT(PSDCODE,ARRAYDEF:NUMDIMS[F],CONST);
FOR CNT ← 1 TIL ARRAYDEF:NUMDIMS[F] DO
FOR T ← 1 STEP -1 UNTIL 0 DO
BEGIN
P ← ARRAYDEF:BOUNDS[F][CNT,T];
IF RECTYPE(P)=LOC(EXPRN) THEN P←ARRAYDEF:BOUNDS[F][CNT,T+2];
IF RECTYPE(P)=LOC(VARIABLE) THEN
EMITOFFSET(PSDCODE,P)
ELSE
BEGIN
BITS ← SVAL:VAL[P]; ! Convert constant bound to integer;
BITS ← BITS LOR '100000; ! Set sign bit for constants;
EMIT(PSDCODE,BITS,CONST)
END
END
END;
! Declare the events;
C ← BLOCK:EVTS[PARSETREE];
IF C ≠ RNULL THEN
BEGIN
MAKE_REMARK(PSDCODE,"Events");
CNT ← 0;
WHILE C ≠ RNULL DO
BEGIN ! Count the events;
VARBL ← LLOP(C);
CNT ← CNT + 1;
VARIABLE:OFFSET[VARBL] ← OFS;
EMITOFFSET(SYMFIL,VARBL);
OFS ← OFS + 1;
END;
EMIT(PSDCODE,EVTID,CONST);
EMIT(PSDCODE,CNT,CONST);
END;
! Declare each condition monitor;
DEFINE EV_CM = 0; ! event;
DEFINE EXP_CM = 1; ! expression or variable;
DEFINE DUR_CM = 2; ! duration;
DEFINE FORCE_CM = 3; ! force sensing;
DEFINE HARDW_CM = 4; ! hardware monitoring;
! Here's what the various types of condition monitors look like:
for all: (dec) LAB: "condition monitor checker"
for events: CMSKED, <time: 0>, CMTRIG
for variables & expressions: CMSKED, <time: 100>,
<code for boolean condition>, JUMPC LAB, CMTRIG,
for durations: <code to get time to wait>, CMDUR,
for force sensing: {<<code to get force vect>,VMKFRC> or <code to get
force frame>, TMKFRC, <arm & coordinate bits>}
<code to get force value>,CMFORCE,
for hardware monitoring: CMSENSE,
for everyone: <code for conclusion>,
for events and variables & expressions: JUMP (ref) LAB,
for the rest: CMDONE,
In the cmon section of MVAR:
for everyone: <type>, (ref) LAB2, <environment size required>,
for events: <event to wait for>,
for force sensing and hardware monitoring: <bits>;
C ← BLOCK:CMONS[PARSETREE];
CNT ← 0;
HERE ← LABELS ← NEW_RECORD (COLAB);
WHILE C ≠ RNULL DO ! Assign an offset & label to each cmon;
BEGIN
MONITOR ← LLOP(C);
CNT ← CNT + 1;
CMON:OFFSET[MONITOR] ← OFS;
COLAB:LBEL[HERE] ← GENLABEL;
HERE ← COLAB:NEXT[HERE] ← NEW_RECORD(COLAB);
OFS ← OFS + 1;
END;
C ← BLOCK:CMONS[PARSETREE];
IF C ≠ RNULL THEN ! Declare the cmons;
BEGIN
MAKE_REMARK(PSDCODE,"Cmons");
EMIT(PSDCODE,CMNID,CONST);
EMIT(PSDCODE,CNT,CONST);
HERE ← LABELS;
WHILE C ≠ RNULL DO ! Info for CMMAK;
BEGIN "cmdcl"
MONITOR ← LLOP(C);
CTYPE ← IF (T←RECTYPE(CMON:CONDITION[MONITOR])) = LOC(VARIABLE) ∧
VARIABLE:DATATYPE[CMON:CONDITION[MONITOR]] = EVENT_DTYPE THEN EV_CM
ELSE IF T = LOC(VARIABLE) ∨ T = LOC(EXPRN) THEN EXP_CM
ELSE IF T = LOC(DURATION) THEN DUR_CM
ELSE IF T = LOC(FORCE) THEN FORCE_CM
ELSE HARDW_CM;
EMIT(PSDCODE,CTYPE,CONST); ! Tell what type of cmon it is;
EMIT(PSDCODE,COLAB:LBEL[HERE],SYMREF); ! Tell where the cmon starts;
HERE ← COLAB:NEXT[HERE];
T ← ENV_SIZE(CMON:CONCLUSION[MONITOR]);
EMIT(PSDCODE,T,CONST); ! How large an environment it will need;
IF CTYPE = EV_CM THEN ! Which event to wait for;
EMITOFFSET(PSDCODE,CMON:CONDITION[MONITOR])
ELSE IF CTYPE = FORCE_CM THEN ! What frcsig needs to know;
BEGIN ! Figure out the bits;
F ← CMON:CONDITION[MONITOR];
BITS ← FORCE:REL[F] + (IF FORCE:DIRECT[F] = ZHAT THEN ZFORCE ELSE
IF FORCE:DIRECT[F] = YHAT THEN YFORCE ELSE XFORCE);
IF ¬FORCE:TYPE[F] THEN BITS ← BITS + XMOMENT; ! It's a torque;
BITS ← BITS +
(IF W_ARM_ON(CMON:FLAGS[MONITOR]) THEN YELARM ELSE BLUARM);
IF CMON:FLAGS[MONITOR] LAND FSTOP THEN BITS ← BITS + FSTOP;
EMIT(PSDCODE,BITS,CONST);
END
! ELSE IF CTYPE = HARDW_CM THEN who knows what we need to do;
END "cmdcl";
END;
! Declare the procedures;
C ← BLOCK:PROCS[PARSETREE];
CNT ← 0;
WHILE C ≠ RNULL DO ! Assign an offset & a label to each procedure;
BEGIN
CNT ← CNT + 1;
F ← LLOP(C);
PROCDEF:OFFSET[F] ← OFS;
PROCDEF:LAB[F] ← GENLABEL;
OFS ← OFS + 1
END;
C ← BLOCK:PROCS[PARSETREE];
IF C ≠ RNULL THEN
BEGIN
MAKE_REMARK(PSDCODE,"Procedures");
EMIT(PSDCODE,PROID,CONST);
EMIT(PSDCODE,CNT,CONST);
END;
WHILE C ≠ RNULL DO ! Emit the procedure header info;
BEGIN
F ← LLOP(C);
MAKE_REMARK(PSDCODE,PROCDEF:NAME[F]);
EMIT(PSDCODE,PROCDEF:NUMARGS[F],CONST);
EMIT(PSDCODE,PROCDEF:LAB[F],SYMREF); ! Start of procedure's body;
T ← ENV_SIZE(PROCDEF:BODY[F]);
EMIT(PSDCODE,T,CONST);
F ← PROCDEF:ARGS[F];
WHILE F ≠ RNULL DO
BEGIN
P ← LLOP(F);
IF RECTYPE(P) = LOC(VARIABLE) THEN
T ← TYPE_GET(VARIABLE:DATATYPE[P]) +
! May want to change this if VALUE becomes the default;
(IF VALARG_ON(VARIABLE:ATTRIBUTES[P]) THEN 0 ELSE REFID)
ELSE T ← TYPE_GET(ARRAYDEF:DATATYPE[P]) + ARYID + REFID;
EMIT(PSDCODE,T,CONST)
END
END;
EMIT(PSDCODE,0,CONST); ! End MVAR with a zero;
! TSCAN: BLOCK continued;
C ← BLOCK:CMONS[PARSETREE]; ! Emit code for each cmon;
IF C ≠ RNULL THEN
BEGIN "cmmak"
LAB1 ← GENLABEL;
EMIT(PSDCODE,JUMP_PSOP,PSINST); ! Jump past cmon bodies;
EMIT(PSDCODE,LAB1,SYMREF);
MAKE_REMARK(PSDCODE,"Condition monitors");
COFS ← OFS;
HERE ← LABELS;
WHILE C ≠ RNULL DO
BEGIN "blkcmon"
MONITOR ← LLOP(C);
OFS ← (COFS LAND '17400) + '400;! Move to next lexical level, offset 0;
CTYPE ← IF (T←RECTYPE(CMON:CONDITION[MONITOR])) = LOC(VARIABLE) ∧
VARIABLE:DATATYPE[CMON:CONDITION[MONITOR]] = EVENT_DTYPE THEN EV_CM
ELSE IF T = LOC(VARIABLE) ∨ T = LOC(EXPRN) THEN EXP_CM
ELSE IF T = LOC(DURATION) THEN DUR_CM
ELSE IF T = LOC(FORCE) THEN FORCE_CM
ELSE HARDW_CM;
MAKE_REMARK(PSDCODE,"Condition monitor checker");
EMIT(PSDCODE,COLAB:LBEL[HERE],SYMDEC); ! Cmon start address;
CASE CTYPE OF BEGIN "c-m checker"
[EV_CM] BEGIN "cmevt" ! An event to wait for;
EMIT(PSDCODE,CMSKED_PSOP,PSINST);
EMIT(PSDCODE,CMTRIG_PSOP,PSINST);
END "cmevt";
[EXP_CM] BEGIN "cmexpr" ! An expression to be evaluated;
EMIT(PSDCODE,CMSKED_PSOP,PSINST);
EMIT(PSDCODE,100,CONST); ! Waiting interval;
EMITBOOL(CMON:CONDITION[MONITOR],0,COLAB:LBEL[HERE]);
EMIT(PSDCODE,CMTRIG_PSOP,PSINST);
END "cmexpr";
[DUR_CM] BEGIN "cmdur" ! A duration to wait for;
EMITEXPR(DURATION:TIME[CMON:CONDITION[MONITOR]]); ! Get the time;
EMIT(PSDCODE,CMDUR_PSOP,PSINST);
END "cmdur";
[FORCE_CM] BEGIN "cmforce" ! A force to wait for;
F ← CMON:CONDITION[MONITOR];
IF FORCE:DIRECT[F] ≠ XHAT ∧ FORCE:DIRECT[F] ≠ YHAT
∧ FORCE:DIRECT[F]≠ZHAT THEN
BEGIN ! Need to make force frame;
EMITEXPR(FORCE:DIRECT[F]); ! Get force vector;
EMIT(PSDCODE,VMKFRC_PSOP,PSINST); ! Make up force frame;
EMIT(PSDCODE,TFRCST_PSOP,PSINST); ! Set it up;
DUMY ← FTABLE +
(IF W_ARM_ON(CMON:FLAGS[MONITOR]) THEN YELARM ELSE BLUARM);
EMIT(PSDCODE,DUMY,CONST); ! Bits for SETC;
END
ELSE IF FORCE:F_F[F] ≠ RNULL THEN
BEGIN ! Need to set up force frame;
EMITEXPR(F_FRAME:FRAME[FORCE:F_F[F]]); ! Get force frame;
EMIT(PSDCODE,TFRCST_PSOP,PSINST); ! Set it up;
EMIT(PSDCODE,F_FRAME:C_SYS[FORCE:F_F[F]],CONST); ! Bits for SETC;
END;
EMITEXPR(FORCE:VAL[CMON:CONDITION[MONITOR]]); ! Get force value;
EMIT(PSDCODE,CMFORCE_PSOP,PSINST);
END "cmforce";
[HARDW_CM] EMIT(PSDCODE,CMSENSE_PSOP,PSINST)
END "c-m checker";
TSCAN(CMON:CONCLUSION[MONITOR]);
IF CTYPE = EV_CM ∨ CTYPE = EXP_CM THEN
BEGIN
EMIT(PSDCODE,JUMP_PSOP,PSINST);
EMIT(PSDCODE,COLAB:LBEL[HERE],SYMREF); ! Cmon start address;
END
ELSE EMIT(PSDCODE,CMDONE_PSOP,PSINST);
HERE ← COLAB:NEXT[HERE];
END "blkcmon";
EMIT(PSDCODE,LAB1,SYMDEC); ! So we can jump past the code for cmons;
OFS ← COFS; ! Restore lexical level;
END "cmmak";
! Make the procedure bodies local to this block;
C ← BLOCK:PROCS[PARSETREE];
IF C ≠ RNULL THEN
BEGIN "proc make"
LAB1 ← GENLABEL;
EMIT(PSDCODE,JUMP_PSOP,PSINST); ! Jump past procedure bodies;
EMIT(PSDCODE,LAB1,SYMREF);
MAKE_REMARK(PSDCODE,"Procedures bodies");
COFS ← OFS;
WHILE C ≠ RNULL DO
BEGIN
F ← LLOP(C); ! Get procedure header;
OFS ← (COFS LAND '17400) + '400;! Move to next lexical level, offset 0;
EMIT(PSDCODE,PROCDEF:LAB[F],SYMDEC);
MAKE_REMARK(PSDCODE,PROCDEF:NAME[F]);
P ← PROCDEF:ARGS[F];
WHILE P ≠ RNULL DO
BEGIN ! Assign offsets to procedure arguments;
VARIABLE:OFFSET[CELL:CAR[P]] ← OFS;
OFS ← OFS + 1;
EMITOFFSET(SYMFIL,LLOP(P)) ! Who knows what ALAID will do with them;
END;
P ← BLOCK:CODE[STMNT:SEMANTICS[PROCDEF:BODY[F]]];
WHILE P ≠ RNULL DO ! Generate code for the stmnts in the procedure;
TSCAN(LLOP(P));
CASE PROCDEF:DATATYPE[F] OF
BEGIN ! Make sure typed procedures return something;
[0] ; ! Not typed so don't bother putting anything on the stack;
[SVAL_DTYPE] EMITEXPR(FALSEV);
[V3ECT_DTYPE] EMITEXPR(NILVECT);
ELSE EMITEXPR(NILTRANS)
END;
EMIT(PSDCODE,RETURN_PSOP,PSINST);
IF PROCDEF:DATATYPE[F]=0 THEN EMIT(PSDCODE,0,CONST)
ELSE EMIT(PSDCODE,-1,CONST);
END;
EMIT(PSDCODE,LAB1,SYMDEC);
OFS ← COFS ! Restore lexical level;
END "proc make"
END "make some variables";
! Generate the code for the statements in the block;
C ← BLOCK:CODE[PARSETREE];
WHILE C ≠ RNULL DO
TSCAN(LLOP(C));
IF (T ← (OFS - SAVOFS) LAND '377) THEN
BEGIN
MAKE_REMARK(PSDCODE,"Block end cleanup");
EMIT(PSDCODE,KVAR_PSOP,PSINST); ! Kill all the variables we made;
EMIT(PSDCODE,T,CONST);
OFS ← SAVOFS; ! Restore the offset to original state;
END;
MAKE_REMARK(PSDCODE,"End of BLOCK");
END "block"
! TSCAN: COBLOCK;
ELSE IF STYP = LOC(COBLOCK) THEN
BEGIN "coblock"
RCLASS COLAB (INTEGER LBEL; RPTR(COLAB) NEXT);
RPTR (COLAB) LABELS, HERE;
INTEGER SAVOFS; ! Holds OFS for the duration;
RCELL C;
PRELOAD_WITH JUMP_PSOP, DUMMY, ! 1-2;
SPROUT_PSOP, DUMMY, ! 3-4;
TERMINATE_PSOP, ! 5;
DUMMY; ! 6;
INTEGER OWN ARRAY DATA[1:6];
PRELOAD_WITH PSINST, SYMREF, ! 1-2;
PSINST, SYMREF, ! 3-4;
PSINST, ! 5;
SYMDEC; ! 6;
INTEGER OWN ARRAY RELOC[1:6];
HERE ← LABELS ← NEW_RECORD (COLAB);
LAB1 ← DATA[2] ← GENLABEL;
MAKE_REMARK(PSDCODE,"Coblock");
EMIT(PSDCODE,DATA[1],RELOC[1],2); ! Jump to end label;
SAVOFS ← OFS;
OFS ← (OFS LAND '17400) + '400; ! Move to next lexical level, offset 0;
C ← COBLOCK:CODE[PARSETREE];
WHILE C ≠ RNULL DO
BEGIN "onecob"
HERE ← COLAB:NEXT[HERE] ← NEW_RECORD(COLAB);
DATA[6] ← COLAB:LBEL[HERE] ← GENLABEL;
EMIT(PSDCODE,DATA[6],RELOC[6],1); ! symdec;
MAKE_REMARK(PSDCODE," Costatement");
TSCAN(LLOP(C));
EMIT(PSDCODE,DATA[5],RELOC[5],1); ! Terminate;
END "onecob";
OFS ← SAVOFS; ! Back to previous level;
DATA[6] ← LAB1; ! Label for jump around cocode;
EMIT(PSDCODE,DATA[6],RELOC[6],1); ! symdec;
HERE ← COLAB:NEXT[LABELS];
C ← COBLOCK:CODE[PARSETREE];
MAKE_REMARK(PSDCODE," epilog of Coblock");
EMIT(PSDCODE,DATA[3],RELOC[3],1); ! Sprout;
WHILE HERE ≠ RNULL DO
BEGIN
DATA[4] ← COLAB:LBEL[HERE];
EMIT(PSDCODE,DATA[4],RELOC[4],1); ! Label of code;
LAB4 ← ENV_SIZE(LLOP(C));
EMIT(PSDCODE,LAB4,CONST); ! Environment size needed;
HERE ← COLAB:NEXT[HERE];
END;
EMIT(PSDCODE,0,CONST,1); ! Final zero;
MAKE_REMARK(PSDCODE,"END COBLOCK");
END "coblock"
! TSCAN: FORR, WHIL, UNTL, IFF, CASE, PAUSE, PROMPT, ABORT;
ELSE IF STYP = LOC(FORR) THEN
BEGIN "forr"
! This is how it currently looks: [FOR LOOP] <stack initial,
final, step> LAB1: XCOPY 2 (current value) XCHNGE <control
variable> XFORCHK LAB2 <body> XCOPY 0 (step size) XCOPY 3
(current value) XSADD XREPLACE 3 (current value) XJUMP LAB1
LAB2: XPOP XPOP XPOP [END FOR];
! This is how it all should look: [FOR LOOP] <stack initial,
final, step> LAB1: XFORCHK <control variable> LAB2 <body>
XFOREND LAB1 LAB2: [END FOR];
MAKE_REMARK(PSDCODE,"FOR LOOP");
EMITEXPR(FORR:INITIAL[PARSETREE]);
! This will emit code for the calculation of the initial
value;
EMITEXPR(FORR:FINAL[PARSETREE]);
! This will emit code for the calculation of the final
value;
EMITEXPR(FORR:STEP[PARSETREE]);
! This will emit code for the calculation of the step
value;
LAB1 ← GENLABEL; ! Top of loop;
LAB2 ← GENLABEL; ! End of loop;
EMIT(PSDCODE,LAB1,SYMDEC);
EMIT(PSDCODE,COPY_PSOP,PSINST);
EMIT(PSDCODE,2,CONST);
IF RECTYPE(FORR:CONVAR[PARSETREE]) = LOC(EXPRN) THEN
BEGIN
RCELL C;
MAKE_REMARK(PSDCODE,"Array reference");
C ← EXPRN:ARGS[FORR:CONVAR[PARSETREE]];
EMITSUBS(CELL:CDR[C]);
EMIT(PSDCODE,CHNGE_PSOP,PSINST);
EMITOFFSET(PSDCODE,CELL:CAR[C])
END
ELSE
BEGIN
EMIT(PSDCODE,CHNGE_PSOP,PSINST);
EMITOFFSET(PSDCODE,FORR:CONVAR[PARSETREE])
END;
EMIT(PSDCODE,FORCHK_PSOP,PSINST);
EMIT(PSDCODE,LAB2,SYMREF);
TSCAN(FORR:BODY[PARSETREE]);
EMIT(PSDCODE,COPY_PSOP,PSINST);
EMIT(PSDCODE,0,CONST);
EMIT(PSDCODE,COPY_PSOP,PSINST);
EMIT(PSDCODE,3,CONST);
EMIT(PSDCODE,SADD_PSOP,PSINST);
EMIT(PSDCODE,REPLACE_PSOP,PSINST);
EMIT(PSDCODE,3,CONST);
EMIT(PSDCODE,JUMP_PSOP,PSINST);
EMIT(PSDCODE,LAB1,SYMREF);
EMIT(PSDCODE,LAB2,SYMDEC);
EMIT(PSDCODE,POP_PSOP,PSINST);
EMIT(PSDCODE,POP_PSOP,PSINST);
EMIT(PSDCODE,POP_PSOP,PSINST);
MAKE_REMARK(PSDCODE,"END FOR");
END "forr"
ELSE IF STYP = LOC(WHIL) THEN
BEGIN "while"
MAKE_REMARK(PSDCODE,"WHILE Loop");
LAB1 ← GENLABEL; ! Loop head;
LAB2 ← GENLABEL; ! After end;
EMIT(PSDCODE,LAB1,SYMDEC); ! (dec) LAB1: ;
EMITBOOL(WHIL:COND[PARSETREE],0,LAB2);
TSCAN(WHIL:BODY[PARSETREE]);
! JUMP (ref) LAB1, (dec) LAB2: ;
EMIT(PSDCODE,JUMP_PSOP,PSINST);
EMIT(PSDCODE,LAB1,SYMREF);
EMIT(PSDCODE,LAB2,SYMDEC);
MAKE_REMARK(PSDCODE,"END WHILE");
END "while"
ELSE IF STYP = LOC(UNTL) THEN
BEGIN "until"
MAKE_REMARK(PSDCODE,"DO UNTIL Loop");
LAB1 ← GENLABEL; ! Loop head;
EMIT(PSDCODE,LAB1,SYMDEC); ! (dec) LAB1: ;
TSCAN(UNTL:BODY[PARSETREE]); ! Loop body;
EMITBOOL(UNTL:COND[PARSETREE],0,LAB1); ! Exit test;
MAKE_REMARK(PSDCODE,"END DO UNTIL");
END "until"
ELSE IF STYP = LOC(IFF) THEN
BEGIN "iff"
MAKE_REMARK(PSDCODE,"IF");
LAB1 ← GENLABEL; ! The head of the ELSE part;
LAB2 ← GENLABEL; ! At the end of the IF;
EMITBOOL(IFF:COND[PARSETREE],0,LAB1);
MAKE_REMARK(PSDCODE,"THEN");
TSCAN(IFF:THN[PARSETREE]);
! JUMP (ref) LAB2, (dec) LAB1: ;
EMIT(PSDCODE,JUMP_PSOP,PSINST);
EMIT(PSDCODE,LAB2,SYMREF);
EMIT(PSDCODE,LAB1,SYMDEC);
IF IFF:ELS[PARSETREE] ≠ NULL
THEN BEGIN
MAKE_REMARK(PSDCODE,"ELSE");
TSCAN(IFF:ELS[PARSETREE]);
END;
EMIT(PSDCODE,LAB2,SYMDEC); ! (dec) LAB2: ;
MAKE_REMARK(PSDCODE,"FI");
END "iff"
ELSE IF STYP = LOC(KASE) THEN
BEGIN "case"
RCELL C;
INTEGER S,I,N;
MAKE_REMARK(PSDCODE,"CASE");
EMITEXPR(KASE:INDEX[PARSETREE]); ! Get the case index on the stack;
N ← KASE:RANGE[PARSETREE];
S ← KASE:NSTMNTS[PARSETREE];
EMIT(PSDCODE,CASE_PSOP,PSINST);
EMIT(PSDCODE,N,CONST); ! Max index value (+1) or -max if ELSE given;
FOR I ← 0 TIL S DO ! Assign labels to each statement;
KASE:LABS[PARSETREE][I,1] ← GENLABEL;
LAB1 ← KASE:LABS[PARSETREE][S,1];
IF N ≥ 0 THEN KASE:LABS[PARSETREE][N,1] ← LAB1 ELSE N ← ABS N;
! So null statements jump to right place;
FOR I ← 0 TIL N DO ! Make dispatch table;
EMIT(PSDCODE,KASE:LABS[PARSETREE][KASE:LABS[PARSETREE][I,0],1],SYMREF);
C ← KASE:STMNTS[PARSETREE];
FOR I ← 0 TIL S-1 DO ! Now emit the labelled statements;
BEGIN
EMIT(PSDCODE,KASE:LABS[PARSETREE][I,1],SYMDEC);
TSCAN(LLOP(C));
IF I ≠ S-1 THEN
BEGIN ! A slight optimization(?);
EMIT(PSDCODE,JUMP_PSOP,PSINST); ! Jump to next statement;
EMIT(PSDCODE,LAB1,SYMREF)
END
END;
EMIT(PSDCODE,LAB1,SYMDEC)
END "case"
ELSE IF STYP = LOC(PAUSE) THEN
BEGIN "pause"
MAKE_REMARK(PSDCODE,"PAUSE");
! Get the value on the stack;
EMITEXPR(PAUSE:VAL[PARSETREE]);
EMIT(PSDCODE,PAUSE_PSOP,PSINST);
END "pause"
ELSE IF STYP = LOC(PROMPT) THEN
BEGIN "prompt"
MAKE_REMARK(PSDCODE,"PROMPT");
PRINT_LIST(PROMPT:VAL[PARSETREE]); ! Take care of any print items;
EMIT(PSDCODE,PROMPT_PSOP,PSINST);
END "prompt"
ELSE IF STYP = LOC(ABORT) THEN
BEGIN "abort"
MAKE_REMARK(PSDCODE,"ABORT");
EMIT(PSDCODE,ABORT_PSOP,PSINST);
PRINT_LIST(ABORT:VAL[PARSETREE]); ! Take care of print items;
MAKE_REMARK(PSDCODE,"DDT"); ! Control passes to DDT;
EMIT(PSDCODE,DDT_PSOP,PSINST);
END "abort"
ELSE GO TO MIDLABEL;
GO TO ENDLABEL; ! This is to avoid parse stack overflow;
! TSCAN: ASSIGNMENT, PRNT, CALL, RETURN, GASSIGN, ALSODO;
MIDLABEL: ! Necessary to avoid parse stack overflow;
IF STYP = LOC(ASSIGNMENT) THEN
BEGIN "assignment"
MAKE_REMARK(PSDCODE,"Assignment");
! Get the value on the stack;
EMITEXPR(ASSIGNMENT:VAL[PARSETREE]);
! Emit "change variable to value on stack";
IF RECTYPE(ASSIGNMENT:VAR[PARSETREE]) = LOC(EXPRN) THEN
BEGIN
RCELL C;
MAKE_REMARK(PSDCODE,"Array reference");
C ← EXPRN:ARGS[ASSIGNMENT:VAR[PARSETREE]];
EMITSUBS(CELL:CDR[C]);
EMIT(PSDCODE,CHNGE_PSOP,PSINST);
EMITOFFSET(PSDCODE,CELL:CAR[C])
END
ELSE
BEGIN
EMIT(PSDCODE,CHNGE_PSOP,PSINST);
EMITOFFSET(PSDCODE,ASSIGNMENT:VAR[PARSETREE])
END
END "assignment"
ELSE IF STYP = LOC(PRNT) THEN
PRINT_LIST(PRNT:VAL[PARSETREE]) ! Take care of print items;
ELSE IF STYP = LOC(EXPRN) THEN
BEGIN "procedure call"
EMITCALL(PARSETREE);
IF PROCDEF:DATATYPE[CELL:CAR[EXPRN:ARGS[PARSETREE]]] ≠ 0 THEN
EMIT(PSDCODE,POP_PSOP,PSINST) ! Flush value procedure returned;
END
ELSE IF STYP = LOC(RETRN) THEN
BEGIN "procedure return"
MAKE_REMARK(PSDCODE,"Return");
IF RETRN:VAL[PARSETREE] ≠ RNULL THEN
EMITEXPR(RETRN:VAL[PARSETREE]);
EMIT(PSDCODE,RETURN_PSOP,PSINST);
IF RETRN:VAL[PARSETREE] ≠ RNULL THEN EMIT(PSDCODE,-1,CONST)
ELSE EMIT(PSDCODE,0,CONST);
END
! TSCAN: CMON, CMABLE;
ELSE IF STYP = LOC(CMON) THEN
BEGIN
IF ¬DEFER_ON(CMON:FLAGS[PARSETREE]) THEN
BEGIN "cmon"
MAKE_REMARK(PSDCODE,"Enable condition monitor");
EMIT(PSDCODE,CMENBL_PSOP,PSINST);
EMIT(PSDCODE,CMON:OFFSET[PARSETREE],CONST);
END "cmon"
END
ELSE IF STYP = LOC(CMABLE) THEN
BEGIN "cmable"
RPTR(CMON,LBLVAR) CMONV; ! The CMON;
CMONV ← CMABLE:WHAT[PARSETREE];
IF RECTYPE(CMONV) = LOC(LBLVAR)
THEN CMONV ← LBLVAR:SEMANTICS[CMONV];
IF CMABLE:FLAG[PARSETREE]
THEN BEGIN "disable"
MAKE_REMARK(PSDCODE,"Disable");
EMIT(PSDCODE,CMDSBL_PSOP,PSINST); ! CMDSBL (offset);
EMIT(PSDCODE,CMON:OFFSET[CMONV],CONST);
END "disable"
ELSE BEGIN "enable"
MAKE_REMARK(PSDCODE,"Enable");
EMIT(PSDCODE,CMENBL_PSOP,PSINST); ! CMENBL (offset);
EMIT(PSDCODE,CMON:OFFSET[CMONV],CONST);
END "enable"
END "cmable"
! TSCAN: MOVE$, CENTER, STOP, SETBASE, WRIST;
ELSE IF STYP = LOC(MOVE$) THEN
BEGIN "move"
RPTR(DEXPR) DESTEXPR; ! The destiniation expression;
RPTR(ARRIVAL) ARR; ! Arrival clause (if any);
RCELL CLAUS; ! The list of clauses;
INTEGER BITS;
RANY X;
MAKE_REMARK(PSDCODE,"Move");
! Generate code for all deproaches & via points that are expressions;
CLAUS ← MOVE$:CLAUSES[PARSETREE];
WHILE CLAUS ≠ RNULL DO
BEGIN "mexpr"
RANY THISCLAUSE;
THISCLAUSE ← LLOP(CLAUS);
IF RECTYPE(THISCLAUSE) = LOC(VIA) AND
RECTYPE(DEXPR:EXPN[VIA:ACTPLACE[THISCLAUSE]]) = LOC(EXPRN)
THEN BEGIN "via"
EMITEXPR(DEXPR:EXPN[VIA:ACTPLACE[THISCLAUSE]]);
EMIT(PSDCODE,CHNGE_PSOP,PSINST);
EMITOFFSET(PSDCODE,DEXPR:VAR[VIA:ACTPLACE[THISCLAUSE]]);
END "via";
IF RECTYPE(THISCLAUSE) = LOC(DEPARTURE) AND
RECTYPE(DEXPR:EXPN[DEPARTURE:ACTPLACE[THISCLAUSE]]) = LOC(EXPRN)
THEN BEGIN "dep"
EMITEXPR(DEXPR:EXPN[DEPARTURE:ACTPLACE[THISCLAUSE]]);
EMIT(PSDCODE,CHNGE_PSOP,PSINST);
EMITOFFSET(PSDCODE,DEXPR:VAR[DEPARTURE:ACTPLACE[THISCLAUSE]]);
END "dep";
IF RECTYPE(THISCLAUSE) = LOC(ARRIVAL)
THEN BEGIN "arr"
ARR←THISCLAUSE;
IF RECTYPE(DEXPR:EXPN[ARRIVAL:ACTPLACE[THISCLAUSE]])=LOC(EXPRN) THEN
BEGIN
EMITEXPR(DEXPR:EXPN[ARRIVAL:ACTPLACE[THISCLAUSE]]);
EMIT(PSDCODE,CHNGE_PSOP,PSINST);
EMITOFFSET(PSDCODE,DEXPR:VAR[ARRIVAL:ACTPLACE[THISCLAUSE]]);
END;
END "arr";
END "mexpr";
! Generate code for the destination point, if it is an expression;
DESTEXPR ← MOVE$:DEXP[PARSETREE];
IF RECTYPE(DEXPR:EXPN[DESTEXPR]) = LOC(EXPRN)
THEN BEGIN "movdest" ! Must emit code to evaluate the destination;
EMITEXPR(DEXPR:EXPN[DESTEXPR]);
EMIT(PSDCODE,CHNGE_PSOP,PSINST);
EMITOFFSET(PSDCODE,DEXPR:VAR[DESTEXPR]);
END "movdest";
! Set up force frame (if any);
CLAUS ← MOVE$:CLAUSES[PARSETREE];
WHILE CLAUS ≠ RNULL DO
BEGIN
X ← LLOP(CLAUS);
IF RECTYPE(X) = LOC(F_FRAME) THEN
BEGIN "f_frame"
EMITEXPR(F_FRAME:FRAME[X]); ! Get force frame;
EMIT(PSDCODE,TFRCST_PSOP,PSINST); ! Set it up;
BITS ← F_FRAME:C_SYS[X] lor
MEMLOC(IF MOVE$:CF[PARSETREE]=YARM THEN YELARM ELSE BLUARM,INTEGER);
EMIT(PSDCODE,BITS,CONST); ! Bits for arm & co_ord sys;
! (hand or table);
DONE;
END "f_frame";
END;
! Set up all forces being applied in this MOVE;
CLAUS ← MOVE$:CLAUSES[PARSETREE];
WHILE CLAUS ≠ RNULL DO
BEGIN
X ← LLOP(CLAUS);
IF RECTYPE(X) = LOC(FORCE) THEN
BEGIN "force"
! First set up the control bits for COMPLY;
IF FORCE:DIRECT[X] = XHAT THEN BITS ← XFORCE
ELSE IF FORCE:DIRECT[X] = YHAT THEN BITS ← YFORCE
ELSE IF FORCE:DIRECT[X] = ZHAT THEN BITS ← ZFORCE
ELSE BEGIN "make force frame"
BITS ← XFORCE;
EMITEXPR(FORCE:DIRECT[X]); ! Get force vector;
EMIT(PSDCODE,VMKFRC_PSOP,PSINST); ! Make force frame;
EMIT(PSDCODE,TFRCST_PSOP,PSINST); ! Set it up;
EMIT(PSDCODE,F_FRAME:C_SYS[FORCE:F_F[X]],CONST); ! Bits for SETC;
END "make force frame";
IF ¬FORCE:TYPE[X] THEN BITS ← BITS + XMOMENT; ! It's a torque;
BITS ← BITS + (IF MOVE$:CF[PARSETREE]=YARM THEN YELARM ELSE BLUARM);
EMITEXPR(FORCE:VAL[X]); ! Get the force's magnitude;
EMIT(PSDCODE,COMPLY_PSOP,PSINST);
EMIT(PSDCODE,BITS,CONST); ! Bits for COMPLY;
END "force";
END;
! Enable any condition monitors local to this move statement;
CLAUS ← MOVE$:CLAUSES[PARSETREE];
WHILE CLAUS ≠ RNULL DO
BEGIN
X←LLOP(CLAUS);
IF RECTYPE(X)=LOC(CMON) ∧ ¬DEFER_ON(CMON:FLAGS[X]) THEN
BEGIN "cmon"
MAKE_REMARK(PSDCODE,"Enable condition monitor");
EMIT(PSDCODE,CMENBL_PSOP,PSINST);
EMIT(PSDCODE,CMON:OFFSET[X],CONST);
END "cmon"
END;
TRJCLC(PARSETREE);
! Disable any condition monitors local to this move statement;
CLAUS ← MOVE$:CLAUSES[PARSETREE];
WHILE CLAUS ≠ RNULL DO
BEGIN
X←LLOP(CLAUS);
IF RECTYPE(X)=LOC(CMON) THEN
BEGIN "cmon"
MAKE_REMARK(PSDCODE,"Disable condition monitor");
EMIT(PSDCODE,CMDSBL_PSOP,PSINST);
EMIT(PSDCODE,CMON:OFFSET[X],CONST);
END "cmon"
END;
! Update deproach variable if need be;
IF ARR≠RNULL THEN
BEGIN
IF ARRIVAL:THRU[ARR]=NILDEPROACH THEN EMITEXPR(NILDEPROACH)
ELSE EMITEXPR(DEXPR:VAR[ARRIVAL:ACTPLACE[ARR]]);
EMIT(PSDCODE,CHNGE_PSOP,PSINST);
IF MOVE$:CF[PARSETREE]=BARM THEN EMITOFFSET(PSDCODE,BDEPROACH)
ELSE EMITOFFSET(PSDCODE,YDEPROACH);
END;
END "move"
ELSE IF STYP = LOC(OPERATE) THEN
BEGIN "operate"
RPTR(MOVE$) MOV; ! Fill this in from the OPERATE record;
RPTR(DEXPR) DESTEXPR; ! The destiniation expression;
RCELL CLAUS; ! The list of clauses;
MAKE_REMARK(PSDCODE,"Operate");
IF OPERATE:WHAT[PARSETREE] ≠ BHAND AND
OPERATE:WHAT[PARSETREE] ≠ YHAND
THEN COMERR("Can't OPERATE a non-hand yet");
MOV ← NEW_RECORD(MOVE$);
MOVE$:WHAT[MOV] ← OPERATE:WHAT[PARSETREE];
MOVE$:DEST[MOV] ← OPERATE:DEST[PARSETREE];
MOVE$:CLAUSES[MOV] ← OPERATE:CLAUSES[PARSETREE];
MOVE$:CF[MOV] ← OPERATE:CF[PARSETREE];
MOVE$:DEXP[MOV] ← OPERATE:DEXP[PARSETREE];
! Generate code for all via points that are expressions;
CLAUS ← MOVE$:CLAUSES[MOV];
WHILE CLAUS ≠ RNULL DO
BEGIN "ovia"
RANY THISCLAUSE;
THISCLAUSE ← LLOP(CLAUS);
IF RECTYPE(THISCLAUSE) = LOC(VIA) AND
RECTYPE(DEXPR:EXPN[VIA:ACTPLACE[THISCLAUSE]]) = LOC(EXPRN)
THEN BEGIN "oprvia"
EMITEXPR(DEXPR:EXPN[VIA:ACTPLACE[THISCLAUSE]]);
EMIT(PSDCODE,CHNGE_PSOP,PSINST);
EMITOFFSET(PSDCODE,DEXPR:VAR[VIA:ACTPLACE[THISCLAUSE]]);
END "oprvia";
END "ovia";
! Generate code for the destination point, if it is an expression;
DESTEXPR ← MOVE$:DEXP[MOV];
IF RECTYPE(DEXPR:EXPN[DESTEXPR]) = LOC(EXPRN)
THEN BEGIN "oprdest" ! Must emit code to evaluate the
destination;
EMITEXPR(DEXPR:EXPN[DESTEXPR]);
EMIT(PSDCODE,CHNGE_PSOP,PSINST);
EMITOFFSET(PSDCODE,DEXPR:VAR[DESTEXPR]);
END "oprdest";
TRJCLC(MOV);
END "operate"
ELSE IF STYP = LOC(CENTER) THEN
BEGIN "center"
MAKE_REMARK(PSDCODE,"Center");
CENTCLC(PARSETREE);
END "center"
ELSE IF STYP = LOC(STOP) THEN
BEGIN "stop"
MAKE_REMARK(PSDCODE,"Stop");
STOPCLC(PARSETREE);
END "stop"
ELSE IF STYP = LOC(SETBASE) THEN
BEGIN "setbase"
MAKE_REMARK(PSDCODE,"Setbase");
EMIT(PSDCODE,SETBASE_PSOP,PSINST);
END "setbase"
ELSE IF STYP = LOC(WRIST) THEN
BEGIN "wrist"
MAKE_REMARK(PSDCODE,"wrist");
EMIT(PSDCODE,WRIST_PSOP,PSINST);
EMITOFFSET(PSDCODE,WRIST:VAL[PARSETREE]);
END "wrist"
! TSCAN: COMMENT, AFFIX, UNFIX;
ELSE IF STYP = LOC(COMMNT) THEN
BEGIN "commnt"
END "commnt"
ELSE IF STYP = LOC(AFFIX) THEN
BEGIN "affix"
INTEGER BITS;
MAKE_REMARK(PSDCODE,"Affixment");
IF AFFIX:ATEXP[PARSETREE] ≠ RNULL THEN
BEGIN ! Explicitly given AT expression;
EMITEXPR(AFFIX:ATEXP[PARSETREE]);
BITS ← 0;
END
ELSE BITS ← '100000; ! Indicate the trans should be computed by runtime;
IF RECTYPE(AFFIX:BYVAR[PARSETREE]) = LOC(EXPRN) THEN
BEGIN
MAKE_REMARK(PSDCODE,"Subscripts for byvar");
EMITSUBS(CELL:CDR[EXPRN:ARGS[AFFIX:BYVAR[PARSETREE]]])
END;
IF RECTYPE(AFFIX:FRAME2[PARSETREE]) = LOC(EXPRN) THEN
BEGIN
MAKE_REMARK(PSDCODE,"Subscripts for frame2");
EMITSUBS(CELL:CDR[EXPRN:ARGS[AFFIX:FRAME2[PARSETREE]]])
END;
IF RECTYPE(AFFIX:FRAME1[PARSETREE]) = LOC(EXPRN) THEN
BEGIN
MAKE_REMARK(PSDCODE,"Subscripts for frame1");
EMITSUBS(CELL:CDR[EXPRN:ARGS[AFFIX:FRAME1[PARSETREE]]])
END;
IF ¬AFFIX:RIGID[PARSETREE] THEN BITS ← BITS + '400; ! Non-rigid;
IF RECTYPE(AFFIX:BYVAR[PARSETREE]) = LOC(EXPRN) ∨
VARIABLE:NAME[AFFIX:BYVAR[PARSETREE]]=NULL THEN LAB1←FALSE ! ALC generated?;
ELSE LAB1←TRUE;
IF LAB1 THEN BITS ← BITS + '2000; ! Explicitly named trans;
EMIT(PSDCODE,AFFIX_PSOP,PSINST);
EMITOFFSET(PSDCODE,AFFIX:FRAME1[PARSETREE]);
EMITOFFSET(PSDCODE,AFFIX:FRAME2[PARSETREE]);
EMIT(PSDCODE,BITS,CONST); ! Tell what type of affixment to make;
IF LAB1 THEN EMITOFFSET(PSDCODE,AFFIX:BYVAR[PARSETREE]);
MAKE_REMARK(PSDCODE,"End of affixment");
END "affix"
ELSE IF STYP = LOC(UNFIX) THEN
BEGIN "unfix"
MAKE_REMARK(PSDCODE,"Unfixment");
IF RECTYPE(UNFIX:FRAME2[PARSETREE]) = LOC(EXPRN) THEN
BEGIN
MAKE_REMARK(PSDCODE,"Subscripts for frame2");
EMITSUBS(CELL:CDR[EXPRN:ARGS[UNFIX:FRAME2[PARSETREE]]])
END;
IF RECTYPE(UNFIX:FRAME1[PARSETREE]) = LOC(EXPRN) THEN
BEGIN
MAKE_REMARK(PSDCODE,"Subscripts for frame1");
EMITSUBS(CELL:CDR[EXPRN:ARGS[UNFIX:FRAME1[PARSETREE]]])
END;
EMIT(PSDCODE,UNFIX_PSOP,PSINST);
EMITOFFSET(PSDCODE,UNFIX:FRAME1[PARSETREE]);
EMITOFFSET(PSDCODE,UNFIX:FRAME2[PARSETREE]);
END "unfix"
! TSCAN: EVDO;
ELSE IF STYP = LOC(EVDO) THEN
BEGIN "evdo"
MAKE_REMARK(PSDCODE,"Event operation");
IF RECTYPE(EVDO:VAR[PARSETREE]) = LOC(EXPRN) THEN
BEGIN
MAKE_REMARK(PSDCODE,"Subscripts for event var");
EMITSUBS(CELL:CDR[EXPRN:ARGS[EVDO:VAR[PARSETREE]]])
END;
IF EVDO:OP[PARSETREE] = 0
THEN EMIT(PSDCODE,SIGNAL_PSOP,PSINST)
ELSE EMIT(PSDCODE,WAITE_PSOP,PSINST);
EMITOFFSET(PSDCODE,EVDO:VAR[PARSETREE]);
END "evdo"
! UNRECOGNIZED;
ELSE IF PARSETREE ≠ RNULL THEN
COMERR("Can't generate code for this",PARSETREE);
ENDLABEL: ! This is here to avoid parse stack overflow;
END "tscan";
END $$prgid;
! Bugs
Global events will not work.
Extra variables are being generated for moves. Can they be suppressed?
;